home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 4 / Info_Mac IV CD-ROM (Pacific HiTech Inc.)(August 1994).iso / Communications / General / FC to Clipboard 2.0 / Pascal Source / FCCommenter.p next >
Text File  |  1993-12-15  |  1KB  |  70 lines
  1. unit FCCommenter;
  2.  
  3. interface
  4.     procedure Main;
  5.  
  6. implementation
  7.  
  8.     procedure MyGetFile (var ok: Boolean; var myFile: FSSpec);
  9.         var
  10.             myReply: StandardFileReply;
  11.             myTypes: SFTypeList;
  12.             error: OSErr;
  13.     begin
  14.         StandardGetFile(nil, -1, myTypes, myReply);
  15.         ok := myReply.sfGood;
  16.         myFile := myReply.sfFile;
  17.     end;
  18.  
  19.     procedure MyGetSITC (var hasSITC: boolean; var myFile: FSSpec; var mySITC: Handle);
  20.         var
  21.             RezRef: Integer;
  22.     begin
  23.         RezRef := FSpOpenResFile(myFile, 0);
  24.         mySITC := Get1Resource('SitC', 0);
  25.         if (ResError <> 0) or (mySITC = nil) then
  26.             hasSITC := false;
  27.         DetachResource(mySITC);
  28.         CloseResFile(RezRef);
  29.     end;
  30.  
  31.     procedure MyPasteInfo (var mySITC: Handle);
  32.         var
  33.             noErr, HLen: LongInt;
  34.     begin
  35.         noErr := ZeroScrap;
  36.         HLen := GetHandleSize(mySITC);
  37.         noErr := PutScrap(HLen, 'TEXT', mySITC^);
  38.     end;
  39.  
  40.     procedure Main;
  41.         type
  42.             data = string[17];
  43.             myData = ^data;
  44.         var
  45.             ok, hasSITC: Boolean;
  46.             myFile: FSSpec;
  47.             mySITC: Handle;
  48.             myPtr: myData;
  49.             noErr: LongInt;
  50.             NA: Str255;
  51.     begin
  52.         MyGetFile(ok, myFile);
  53.         if ok then
  54.             begin
  55.                 MyGetSITC(hasSITC, myFile, mySITC);
  56.                 if hasSITC then
  57.                     begin
  58.                         MyPasteInfo(mySITC);
  59.                         DisposeHandle(mySITC);
  60.                     end
  61.                 else
  62.                     begin
  63.                         myPtr := myData(NewPtr(17));
  64.                         myPtr^ := 'No comment found.';
  65.                         noErr := ZeroScrap;
  66.                         noErr := PutScrap(17, 'TEXT', Ptr(myPtr));
  67.                     end;
  68.             end;
  69.     end;
  70. end.